home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb30.arc / TRBOEXT.PAS < prev    next >
Pascal/Delphi Source File  |  1985-05-07  |  13KB  |  468 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6. {  Turbo Pascal procedure to retrieve command line parameters       }
  7.  
  8.  
  9. type parmtype   = string[127];
  10.  
  11.      anystring  = string[132];
  12.  
  13. var
  14.    tempstring:    anystring;
  15.  
  16.      {  Returns first available parameter from DOS command     }
  17.      {  line and removes it so next parameter will be          }
  18.      {  returned in next call.  If no more parameters are      }
  19.      {  available, returns a null string.                      }
  20.  
  21. procedure getparm(var  s:parmtype);
  22. var   parms:  parmtype absolute CSEG:$80;
  23. begin
  24.    s := '';        { parms[1] exists even when length is zero  }
  25.    while (length(parms) > 0) and (parms[1] = ' ') do
  26.       delete(parms,1,1);
  27.    while (length(parms) > 0) and (parms[1] <> ' ') do
  28.    begin
  29.       s := s+parms[1];
  30.       delete(parms,1,1)
  31.    end;
  32. end;
  33. {
  34. .pa  }
  35.  
  36. {***************************************************************************}
  37. {*                                                                         *}
  38. {*                   Date and Time Functions                               *}
  39. {*                                                                         *}
  40. {***************************************************************************}
  41.  
  42. type datetimetype    = string[8];
  43.      regtype         = record
  44.                        ax,bx,cx,dx,bp,si,di,ds,es,flags:  integer
  45.                        end;
  46.  
  47. function date: datetimetype;    { Returns current date in form '02/08/85'. }
  48. var   reg:   regtype;
  49.       y,m,d,w:  datetimetype;
  50.       i:        integer;
  51.  
  52. begin
  53.    reg.ax := $2A00;
  54.    intr($21,reg);
  55.    str(reg.cx:4,y);
  56.    delete(y,1,2);
  57.    str(hi(reg.dx):2,m);
  58.    str(lo(reg.dx):2,d);
  59.    w := m + '/' + d + '/' + y;
  60.    for i := 1 to length(w) do if w[i] = ' ' then w[i] := '0';
  61.    date := w
  62. end;
  63.  
  64. function time:  datetimetype;    { Returns current time in form '08:13:59'. }
  65. var   reg:     regtype;
  66.       h,m,s,w: datetimetype;
  67.       i:       integer;
  68.  
  69. begin
  70.    reg.ax := $2C00;
  71.    intr($21,reg);
  72.    str(hi(reg.cx):2,h);
  73.    str(lo(reg.cx):2,m);
  74.    str(hi(reg.dx):2,s);
  75.    w := h + ':' + m + ':' + s;
  76.    for i := 1 to length(w) do if w[i] = ' ' then w[i] := '0';
  77.    time := w
  78. end;
  79.  
  80. procedure SetDate(x:datetimetype);   { Sets date  Accepts string in format '02/08/85'.  }
  81. var   reg:            regtype;
  82.       rh,rl,c1,c2,c3: integer;
  83.  
  84. begin
  85.    reg.ax := $2B00;
  86.    val(x[1]+x[2],rh,c1);        { month goes in DH  }
  87.    val(x[4]+x[5],rl,c2);        { day goes in DL    }
  88.    reg.dx := rh*256 + rl;
  89.    val(x[7]+x[8],rl,c3);        { year goes in CX   }
  90.    reg.cx := rl + 1900;
  91.    if rl < 80 then reg.cx := reg.cx + 100;    { 21st century  }
  92.    c1 := c1+c2+c3;              { return codes from val }
  93.    if c1 = 0 then intr($21,reg);
  94.    if c1 + lo(reg.ax) <> 0 then
  95.    begin
  96.       writeln;
  97.       writeln('Error---Invalid date, ''',x,'''');
  98.       halt
  99.    end
  100. end;
  101.  
  102. procedure SetTime(x:datetimetype); { Sets time  Accepts string in format '08:13:59'. }
  103. var   reg:            regtype;
  104.       rh,rl,c1,c2,c3: integer;
  105. begin
  106.    reg.ax := $2D00;
  107.    val(x[1]+x[2],rh,c1);        { Hours go in CH        }
  108.    val(x[4]+x[5],rl,c2);        { Minutes go in CL      }
  109.    reg.cx := rh*256 + rl;
  110.    val(x[7]+x[8],rh,c3);        { Seconds go in DH      }
  111.    reg.dx := rh*256;
  112.    c1 := c1+c2+c3;              { return codes from VAL }
  113.    if c1 = 0 then intr($21,reg);
  114.    if c1+lo(reg.ax) <> 0 then
  115.    begin
  116.       writeln;
  117.       writeln('Error -- Invalid time, ''',x,'''');
  118.       halt
  119.    end
  120. end;
  121. {
  122. .pa  }
  123.  
  124. {***************************************************************************}
  125. {*                                                                         *}
  126. {*                   Directory Tree Functions                              *}
  127. {*                                                                         *}
  128. {***************************************************************************}
  129.  
  130. type    pathtype    = string[63];
  131.         drivetype   = string[2];
  132.         rtype       = record
  133.                         ax,bx,cx,dx,bp,si,di,ds,es,flags:  integer
  134.                       end;
  135.  
  136. procedure XxDiskErr(x:drivetype);
  137. begin
  138.    writeln('Error -- Invalid disk drive, ''',x,'''');
  139.    halt
  140. end;
  141.  
  142. procedure xxpatherr(x:pathtype);
  143. begin
  144.    writeln('Error -- Invalid path, ''',x,'''');
  145.    halt
  146. end;
  147.  
  148. { Returns designator for current default drive, e.g., 'A:'.  }
  149.  
  150. function CurrentDrive:  drivetype;
  151. var   w:   drivetype;
  152.       reg: rtype;
  153. begin
  154.    reg.ax := $1900;
  155.    intr($21,reg);
  156.    w := 'A:';
  157.    w[1] := chr(ord(w[1]) + lo(reg.ax));
  158.    CurrentDrive := w
  159. end;
  160.  
  161. { Chooses a new default drive.      }
  162. { Parameter can have the form 'A:', 'A', 'a:', or 'a'.     }
  163.  
  164. procedure ChDrive(x: drivetype);
  165. var  reg:  rtype;
  166. begin
  167.    reg.ax := $0E00;
  168.    reg.dx := ord(upcase(x[1])) - ord('A');
  169.    intr($21,reg);
  170.    if (reg.dx < 0) or (lo(reg.ax) < lo(reg.dx)) then xxdiskerr(x);
  171. end;
  172.  
  173. { Returns number of bytes available on specified disk.      }
  174. { Parameter as for CHDRIVE.                                 }
  175.  
  176. function DiskSpace(x: drivetype): real;
  177. var  reg: rtype;
  178. begin
  179.    reg.ax := $3600;
  180.    reg.dx := 1 + ord(upcase(x[1])) - ord('A');
  181.    intr($21,reg);
  182.    if reg.ax = $FFFF then
  183.       xxdiskerr(x)
  184.    else
  185.       diskspace := (256.0*hi(reg.dx)+lo(reg.dx)) * reg.ax * reg.cx
  186. end;
  187.  
  188. {  Returns full path to active directory on specified drive,  }
  189. {  including backslash at beginning, not including drive      }
  190. {  designator.  Parameter as for CHDRIVE.                     }
  191.  
  192. function CurrentDir(x: drivetype): pathtype;
  193. var   w:     pathtype;
  194.       reg:   rtype;
  195.       i:     integer;
  196. begin
  197.    reg.ax := $4700;                 { get current path  }
  198.    reg.dx := 1 + ord(upcase(x[1])) - ord('A');
  199.    reg.ds := seg(w[1]);
  200.    reg.si := ofs(w[1]);
  201.    intr($21,reg);
  202.    if (reg.flags and 1) > 0 then xxdiskerr(x);
  203.  
  204. {  Convert to Turbo string  }
  205.    i := 1;
  206.    while w[i] <> chr(0) do i := i+1;
  207.    w[0] := chr(i-1);
  208.    for i := 1 to length(w) do w[i] := upcase(w[i]);
  209.  
  210.    CurrentDir := '\' + w
  211. end;
  212.  
  213. {  Executed CHDIR, MKDIR, and RMDIR requests.     }
  214. procedure xxdir(x: pathtype;  k: integer);
  215. var    w:    pathtype;
  216.        reg:  rtype;
  217. begin
  218.    w := x + chr(0);
  219.    if w[2] <> ':' then    { add drive designator    }
  220.        w := CurrentDrive + w;
  221.     reg.ax := k;
  222.     reg.ds := seg(w[1]);
  223.     reg.dx := ofs(w[1]);
  224.     intr($21,reg);
  225.     if (reg.flags and 1) > 0 then xxpatherr(x)
  226.  end;
  227.  
  228.  
  229. {  Equivalent to CHDIR command in DOS.       }
  230. {  CAUTION!!!!  Do not leave a directory     }
  231. {     if you have files in it open!          }
  232. procedure Chdir(x: pathtype);
  233. begin
  234.    xxdir(x,$3B00)
  235. end;
  236.  
  237.  
  238. {  Equivalent to RMDIR command in DOS.       }
  239.  
  240. procedure Rmdir(x: pathtype);
  241. begin
  242.    xxdir(x,$3A00)
  243. end;
  244.  
  245. {  Equivalent to MKDIR command in DOS.      }
  246. procedure mkdir(x:pathtype);
  247. begin
  248.    xxdir(x,$3900);
  249. end;
  250.  
  251. {  Renames a file; unlike the DOS RENAME command,   }
  252. {  both parameters of this command are full paths.  }
  253. {  The paths need not be the same, allowing a file  }
  254. {  to be moved from one directory to another.       }
  255. {  First parameter can specify a drive; any drive   }
  256. {  letter on the second parameter is ignored.       }
  257.  
  258. procedure rename(x,y: pathtype);
  259. var   wx,wy:   pathtype;
  260.       reg:     rtype;
  261. begin
  262.    wx := x + chr(0);
  263.    wy := y + chr(0);
  264.    if wx[2] <> ':' then wx := currentdrive + wx;
  265.    reg.ax := $5600;
  266.    reg.ds := seg(wx[2]);
  267.    reg.dx := ofs(wx[1]);
  268.    reg.es := seg(wy[1]);
  269.    reg.di := ofs(wy[1]);
  270.    intr($21,reg);
  271.    if (reg.flags and 1) <> 0 then
  272.    begin
  273.       writeln('Error -- Invalid rename request');
  274.       writeln('      -- From: ''',x,'''');
  275.       writeln('      -- To:   ''',y,'''');
  276.       halt
  277.    end
  278. end;
  279. {
  280. .pa  }
  281.  
  282.  
  283. {  Turbo Pascal  removable window system       }
  284.  
  285. {  Requirements:   IBM PC or close compatible. }
  286. {  Screen must be in text mode, on page 1,     }
  287. {  either mono or color card.                  }
  288.  
  289. {  Call INITWIN before calling MKWIN or RMWIN. }
  290.  
  291. const maxwin = 5;              { maximum number of windows open at once   }
  292.  
  293. type  imagetype    = array [1..4096] of char;
  294.       windimtype   = record
  295.                         x1,y1,x2,y2:  integer
  296.                      end;
  297.  
  298. var
  299.    win:                        { Global variable package                 }
  300.       record
  301.          dim:     windimtype;  { Current window dimensions               }
  302.          depth:   integer;
  303.          stack:   array[1..maxwin] of
  304.                      record
  305.                         image:  imagetype;   { saved screen image        }
  306.                         dim:    windimtype;  { saved window dimensions   }
  307.                         x,y:    integer      { saved cursor position     }
  308.                      end
  309.       end;
  310.  
  311.    crtmode:       byte        absolute $0040:$0049;
  312.    crtwidth:      byte        absolute $0040:$004A;
  313.    monobuffer:    imagetype   absolute $B000:$0000;
  314.    colorbuffer:   imagetype   absolute $B800:$0000;
  315.  
  316. procedure InitWin;       {   Records initial window dimensions    }
  317. begin
  318.    with win.dim do
  319.    begin
  320.       x1 := 1;
  321.       y1 := 1;
  322.       x2 := crtwidth;
  323.       y2 := 25
  324.    end;
  325.    win.depth := 0
  326. end;
  327. {
  328. .pa }
  329.  
  330. { Draw a box, fill it with blanks, and make it the current     }
  331. { window.  Dimensions given are for the box; actual window is  }
  332. { one unit smaller in each direction.                          }
  333. { This routine can be used separately from the rest of the     }
  334. { removable window package.                                    }
  335.  
  336. procedure BoxWin(x1,y1,x2,y2:  integer);
  337. var  x,y:  integer;
  338. begin
  339.    window(1,1,80,25);     {Top}
  340.    GotoXY(x1,y1);
  341.    write(chr(213));
  342.    for x := x1+1 to x2-1 do write(chr(205));
  343.    write(chr(184));
  344.  
  345.    for y := y1+1 to y2-1 do  {Sides}
  346.    begin
  347.       GotoXY(x1,y);
  348.       write(chr(179),' ':x2-x1-1,chr(179))
  349.    end;
  350.  
  351.    GotoXY(x1,y2);          {Bottom}
  352.    write(chr(212));
  353.    for x := x1+1 to x2-1 do write(chr(205));
  354.    write(chr(190));
  355.  
  356.    window(x1+1,y1+1,x2-1,y2-1);     { Make it the current window  }
  357.    GotoXY(1,1)
  358. end;
  359.  
  360.  
  361. {  Create a movable window   }
  362.  
  363. procedure MkWin(x1,y1,x2,y2:  integer);
  364. begin
  365.    with win do depth := depth+1;       { increment stack pointer  }
  366.    if win.depth > maxwin then
  367.    begin
  368.       writeln(^G,' Windows nested too deep ');
  369.       halt
  370.    end;
  371.  
  372.                      {  Save contents of screen     }
  373.    if crtmode = 7 then
  374.       win.stack[win.depth].image := monobuffer
  375.    else
  376.       win.stack[win.depth].image := colorbuffer;
  377.  
  378.    win.stack[win.depth].dim := win.dim;
  379.    win.stack[win.depth].x   := wherex;
  380.    win.stack[win.depth].y   := wherey;
  381.  
  382.    { Create the window  }
  383.  
  384.    boxwin(x1,y1,x2,y2);
  385.    win.dim.x1 := x1+1;
  386.    win.dim.y1 := y1+1;    { Allow for margins   }
  387.    win.dim.x2 := x2-1;
  388.    win.dim.y2 := y2-1;
  389. end;
  390.  
  391.   {  Remove the most recently created removable window    }
  392.   {  Restore screen contents, window dimensions, and      }
  393.   {  position of cursor.                                  }
  394.  
  395. procedure rmwin;
  396. begin
  397.    if crtmode = 7 then
  398.       monobuffer := win.stack[win.depth].image
  399.    else
  400.       colorbuffer := win.stack[win.depth].image;
  401.    with win do
  402.    begin
  403.       dim := stack[depth].dim;
  404.       window(dim.x1,dim.y1,dim.x2,dim.y2);
  405.       GotoXY(stack[depth].x,stack[depth].y);
  406.       depth := depth -1
  407.    end
  408. end;
  409.  
  410.  
  411.  
  412.  
  413.  
  414.  
  415. {
  416. .pa  }
  417.  
  418. {  Test program for removable window package    }
  419.  
  420.  
  421. var  i:  integer;
  422. begin
  423.    initwin;
  424.    writeln('Now and every time the action stops,');
  425.    writeln('press ENTER to continue');
  426.    readln;
  427.    clrscr;
  428.    for i := 1 to 25 do writeln('    This is the original screen.');
  429.  
  430.    mkwin(3,3,50,18);
  431.    for i := 1 to 15 do writeln('This is the first window....');
  432.    readln;
  433.  
  434.    mkwin(10,5,70,20);
  435.    for i := 1 to 15 do writeln('Second window....');
  436.    readln;
  437.  
  438.    mkwin(15,15,45,23);
  439.    writeln('Third window...');
  440.    readln;
  441.  
  442.    mkwin(55,10,79,25);
  443.    writeln('Fourth window....');
  444.    readln;
  445.  
  446.    rmwin;    { remove fourth window  }
  447.    readln;
  448.  
  449.    rmwin;    { remove third window   }
  450.    writeln;
  451.    writeln('We are back in the second window...');
  452.    readln;
  453.  
  454.    rmwin;    { remove second window  }
  455.    writeln;
  456.    writeln('This is the first window again!');
  457.    readln;
  458.  
  459.    rmwin;    { remove first window   }
  460.    readln;
  461.  
  462. end.
  463.  
  464. ;
  465.    writeln('This is the first window again!');
  466.    readln;
  467.  
  468.    rmwi